Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE15/SYSTEM/ContextM.pas

Pascal/Delphi Source File | 1996-10-03 | 11.0 KB | 352 lines

unit ContextM;

interface

uses
  Windows, Ole2, ShellAPI;

type
    IShellClassFactory = class (IClassFactory)
    private
        RefCount: LongInt;
    public
        constructor Create;
        function QueryInterface (const iid: TIID; var obj): HResult; override;
        function AddRef: LongInt; override;
        function Release: LongInt; override;
        function LockServer (fLock: Bool): HResult; override;
        function CreateInstance (unknown: IUnknown; const iid: TIID; var obj): HResult; override;
    end;

var
    LockCount, ObjCount: Integer;

implementation

type
    PCMInvokeCommandInfo = ^TCMInvokeCommandInfo;
    TCMInvokeCommandInfo = record
        cbSize: DWord;           { size of data structure }
        fMask: DWord;            { bitwise combination of CMIC_xxx flags }
        hwnd: HWnd;              { handle of window owning context menu }
        lpVerb: LPCStr;          { command string or else menu ID in low word }
        lpParameters: LPCStr;    { always NULL for custom context menus }
        lpDirectory: LPCStr;     { always NULL for custom context menus }
        nShow: Integer;          { for ShowWindow API call if used }
        dwHotKey: DWord;         { optional hotkey - not used by us }
        hIcon: THandle;          { icon handle - not used by us }
    end;

    TContextMenuObject = class;

    IContextMenu = class (IUnknown)
        function QueryContextMenu (Menu: hMenu; indexMenu, idCmdFirst, idCmdLast, uFlags: UInt): HResult; virtual; stdcall; abstract;
        function InvokeCommand (lpici: PCMInvokeCommandInfo): HResult; virtual; stdcall; abstract;
        function GetCommandString (idCmd, uType: UInt; var res: UInt; lpHint: LPSTR; cchMax: UInt): HResult; virtual; stdcall; abstract;
    end;

    IShellExtInit = class (IUnknown)
        function Initialize (pidlFolder: Pointer; pdobj: IDataObject; hKeyProgID: HKey): HResult; virtual; stdcall; abstract;
    end;

    TOwnedContextMenu = class (IContextMenu)
    private
        owner: TContextMenuObject;
    public
        constructor Create (aOwner: TContextMenuObject);
        function QueryInterface (const iid: TIID; var obj): HResult; override;
        function AddRef: LongInt; override;
        function Release: LongInt; override;
        function QueryContextMenu (hMenu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UInt): HResult; override;
        function InvokeCommand (lpici: PCMInvokeCommandInfo): HResult; override;
        function GetCommandString (idCmd, uType: UInt; var res: UInt; pszName: LPStr; cchMax: UInt): HResult; override;
  end;

    TOwnedShellExtInit = class (IShellExtInit)
    private
        owner: TContextMenuObject;
    public
        constructor Create (aOwner: TContextMenuObject);
        function QueryInterface (const iid: TIID; var obj): HResult; override;
        function AddRef: LongInt; override;
        function Release: LongInt; override;
        function Initialize (pidlFolder: Pointer; pdobj: IDataObject; hKeyProgID: HKey): HResult; override;
    end;

    { This is the *REAL* class - it just wraps the two interface classes we need }

    TContextMenuObject = class (IUnknown)
    private
        fName: String;
        RefCount: Integer;
        iContextMenu: TOwnedContextMenu;
        iShellExtInit: TOwnedShellExtInit;
    public
        constructor Create;
        destructor Destroy; override;
        function QueryInterface (const iid: TIID; var obj): HResult; override;
        function AddRef: LongInt; override;
        function Release: LongInt; override;
    end;

{---------------------------------------------------------------------------}
{   Class Factory Methods                                                   }
{---------------------------------------------------------------------------}

constructor IShellClassFactory.Create;
begin
    inherited Create;
    RefCount := 0;
end;

function IShellClassFactory.AddRef: LongInt;
begin
    Inc (RefCount);
    Result := RefCount;
end;

function IShellClassFactory.Release: LongInt;
begin
    Dec (RefCount);
    Result := RefCount;
    if RefCount = 0 then Free;
end;

function IShellClassFactory.LockServer (fLock: Bool): HResult;
begin
    { bump lock count as requested }
    if fLock then Inc (LockCount) else Dec (LockCount);
    Result := 0;
end;

function IShellClassFactory.QueryInterface (const iid: TIID; var obj): HResult;
begin
    if IsEqualIID (iid, IID_IUnknown) or IsEqualIID (iid, IID_IClassFactory) then
    begin
        Pointer (obj) := self;
        AddRef;
        Result := 0;
    end
    else
    begin
        Pointer (obj) := Nil;
        Result := E_NoInterface;
    end;
end;

function IShellClassFactory.CreateInstance (unknown: IUnknown; const iid: TIID; var obj): HResult;
var
    cmo: TContextMenuObject;
begin
    Pointer (obj) := Nil;
    if unknown <> Nil then Result := class_e_NoAggregation
    else
    try
        cmo := TContextMenuObject.Create;
        Result := cmo.QueryInterface (iid, obj);
        if Result < 0 then cmo.Free;
    except
        Result := E_OutOfMemory;
    end;
end;

{---------------------------------------------------------------------------}
{   TContextMenuObject Methods                                              }
{---------------------------------------------------------------------------}

constructor TContextMenuObject.Create;
begin
    inherited Create;
    iContextMenu := TOwnedContextMenu.Create (self);
    iShellExtInit := TOwnedShellExtInit.Create (self);
    RefCount := 0;
    Inc (ObjCount);
end;

destructor TContextMenuObject.Destroy;
begin
    iContextMenu.Free;
    iShellExtInit.Free;
    Dec (ObjCount);
end;

function TContextMenuObject.AddRef: LongInt;
begin
    Inc (RefCount);
    Result := RefCount;
end;

function TContextMenuObject.Release: LongInt;
begin
    Dec (RefCount);
    Result := RefCount;
    if RefCount = 0 then Free;
end;

function TContextMenuObject.QueryInterface (const iid: TIID; var obj): HResult;
const
    { The interface ID's we can respond to }
    IID_IContextMenu : TGUID = (D1:$000214E4; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));
    IID_IShellExtInit: TGUID = (D1:$000214E8; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));
begin
    Result := 0;
    if IsEqualIID (iid, IID_IUnknown) then
    begin
        Pointer (obj) := self;            { Wants IUnknown - return self }
        AddRef;
    end
    else if IsEqualIID (iid, IID_IContextMenu) then
    begin
        Pointer (obj) := iContextMenu;    { Wants IContextMenu - return it }
        AddRef;
    end
    else if IsEqualIID (iid, IID_IShellExtInit) then
    begin
        Pointer (obj) := iShellExtInit;   { Wants IShellExtInit - return it }
        AddRef;
    end
    else
    begin
        Pointer (obj) := nil;
        Result := E_NoInterface;
    end;
end;

{---------------------------------------------------------------------------}
{   TOwnedShellExtInit Methods                                                  }
{---------------------------------------------------------------------------}

constructor TOwnedShellExtInit.Create (aOwner: TContextMenuObject);
begin
    inherited Create;
    owner := aOwner;
end;

function TOwnedShellExtInit.QueryInterface (const iid: TIID; var obj): HResult;
begin
    Result := owner.QueryInterface (iid, obj);
end;

function TOwnedShellExtInit.AddRef: LongInt;
begin
    Result := owner.AddRef;
end;

function TOwnedShellExtInit.Release: LongInt;
begin
    Result := owner.Release;
end;

function TOwnedShellExtInit.Initialize (pidlFolder: Pointer; pdobj: IDataObject; hKeyProgID: HKey): HResult;
var
    fmte: TFormatEtc;
    medium: TStgMedium;
begin
    { Assume the worst ! }
    Result := E_Fail;
    if pdobj <> nil then
    begin
        fmte.cfFormat := cf_hDrop;
        fmte.ptd := nil;
        fmte.dwAspect := dvAspect_Content;
        fmte.lindex := -1;
        fmte.tymed := tymed_hGlobal;

        { Use the given IDataObject to get a list of filenames }
        Result := pdobj.GetData (fmte, medium);
        if Result < 0 then Result := E_Fail
        { Ensure that only one file is selected }
        else if DragQueryFile (HDrop (medium.hGlobal), UInt (-1), Nil, 0) = 1 then
        begin
            { Stash the filename }
            SetLength (owner.fName, 512);
            DragQueryFile (HDrop (medium.hGlobal), 0, PChar (owner.fName), 512);
            Result := 0;
        end
        else Result := E_Fail;
        ReleaseStgMedium (medium);
    end;
end;

{---------------------------------------------------------------------------}
{   TOwnedContextMenu Methods                                               }
{---------------------------------------------------------------------------}

constructor TOwnedContextMenu.Create (aOwner: TContextMenuObject);
begin
    inherited Create;
    owner := aOwner;
end;

function TOwnedContextMenu.QueryInterface (const iid: TIID; var obj): HResult;
begin
    Result := owner.QueryInterface (iid, obj);
end;

function TOwnedContextMenu.AddRef: LongInt;
begin
    Result := owner.AddRef;
end;

function TOwnedContextMenu.Release: LongInt;
begin
    Result := owner.Release;
end;

{ Add commands to a context menu }
function TOwnedContextMenu.QueryContextMenu (hMenu: hMenu; indexMenu, idCmdFirst, idCmdLast, uFlags: UInt): HResult;
begin
    { add our new menu item }
    InsertMenu (hMenu, IndexMenu, mf_String or mf_ByPosition, idCmdFirst, '&Mega Menu...');
    { return number of items added }
    Result := 1;
end;

{ Execute a given menu command }
function TOwnedContextMenu.InvokeCommand (lpici: PCMInvokeCommandInfo): HResult;
var
    sz: array [0..255] of Char;
begin
    Result := E_Fail;
    if HiWord (LongInt (lpici.lpVerb)) = 0 then
    begin
        if loWord (lpici.lpVerb) > 0 then Result := E_InvalidArg
        else
        begin
            { Normally, you'd case out on the menu identifier here }
            case loWord (lpici.lpVerb) of
            0: begin
                   wvsprintf (sz, 'You picked: %s', @owner.fName);
                   MessageBox (lpici.hwnd, sz, 'My First Context Menu', mb_ok);
                   Result := 0;
               end;
            end;
        end;
    end;
end;

{ Return a menu item hint string }
function TOwnedContextMenu.GetCommandString (idCmd, uType: UInt; var res: UInt; pszName: LPStr; cchMax: UInt): HResult;
const
    gcs_HelpText = 1;      { Explorer is requesting a menu hint string }
begin
    { If uType = gcs_HelpText, return a menu hint string for Explorer }
    Result := e_NotImpl;
    if uType = gcs_HelpText then
    begin
        { Case out on the menu item }
        case idCmd of
            0: begin
                   lstrcpy (pszName, 'My very first context menu item !');
                   Result := 0;
               end
            else Result := E_InvalidArg;
        end;
    end;
end;

initialization
    LockCount := 0;
    ObjCount := 0;
end.